Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE06/INTERNAL/DOSINFO.PAS

Pascal/Delphi Source File | 1996-01-11 | 5.9 KB | 202 lines

unit DOSInfo;

interface

uses WinTypes, WinProcs, WinDOS, Strings;

function GetFloppyDriveCount: Integer;
function GetFloppyDriveType (index: Integer): Integer;
function GetDriveLabel (drive: Integer): String;
function SetDriveLabel (drive: Integer; VolLabel: String): Integer;

implementation

type XFCB = record              { prehistoric extended FCB - yuck }
    extSig: Byte;              { must be $FF for extended flag }
    extRes: array [0..4] of Byte;     { reserved stuff }
    extAttr: Byte;              { file attribute }
    extDrive: Byte;              { drive number }
    extFName: array [0..10] of Char;  { filename }
    extJunk: array [0..24] of Byte;   { rest of the junk is irrelevant }
end;

{ Read a single byte from CMOS memory }

function ReadCMOSByte (idx: Byte): Word; assembler;
asm
    mov al,idx                  { get the wanted index           }
    out 70h,al                  { write address into address reg }
    in  al,71h                  { read the drive type into AL    }
    mov ah,0                    { clear the high byte            }
end;

{ Count the number of physical (not logical) floppy drives) }

function GetFloppyDriveCount: Integer;
var
    regs: TRegisters;
begin
    { Get equipment bits }
    FillChar (regs, sizeof (regs), 0);
    Intr ($11, regs);
    if (regs.AX and 1) = 0 then GetFloppyDriveCount := 0 else
    GetFloppyDriveCount := ((regs.AX and $C0) shr 6) + 1;
end;

{ Return the type (max KB capacity) of a given floppy drive }

function GetFloppyDriveType (index: Integer): Integer;
var
    flopFlags: Word;

    function FlagsToKBytes (flags: Word): Integer;
    begin
        case flags of
            0:     FlagsToKBytes := 0;
            1:     FlagsToKBytes := 360;
            2:     FlagsToKBytes := 1200;
            3:     FlagsToKBytes := 720;
            4:     FlagsToKBytes := 1440;
            5:     FlagsToKBytes := 2880;
            else   FlagsToKBytes := -1;
        end
    end;

begin
    flopFlags := ReadCMOSByte ($10);
    case index of
        0: GetFloppyDriveType := FlagsToKBytes (flopFlags shr 4);
        1: GetFloppyDriveType := FlagsToKBytes (flopFlags and 15);
        else GetFloppyDriveType := 0;
    end;
end;

{ Return the drive label of a specified drive }

function GetDriveLabel (drive: Integer): String;
var
    i: Integer;
    s: String;
    rec: WinDOS.TSearchRec;
    path: array [0..10] of Char;
begin
    s := '';
    lstrcpy (path, 'X:\*.*');
    path [0] := Chr (drive + $40);               { 1=A, 2=B, etc... }
    WinDOS.FindFirst (path, 8, rec);
    if WinDOS.DOSError = 0 then
    begin
        for i := 0 to 12 do
            if rec.Name [i] = #0 then break
            else if rec.Name [i] <> '.' then s := s + rec.Name [i];
    end;

    GetDriveLabel := s;
end;

{ Initialise 'fcb' for volume label twiddling - bleurgh ! }

procedure InitLabelFCB (drive: Byte; var fcb: XFCB);
begin
    FillChar (fcb, sizeof (fcb), 0);
    with fcb do
    begin
        extSig := $ff;        { mark FCB as extended }
     extAttr := 8;        { specify VOLUME attribute }
    extDrive := drive;    { set up drive number (1=A, 2=B..) }
    FillChar (extFName, sizeof (extFName), '?');
    end;
end;

{ Trash any existing volume label }

function NukeVolumeLabel (drive: Byte): Integer;
var
    fcb: XFCB;
    regs: TRegisters;
begin
    FillChar (regs, sizeof (regs), 0);
    InitLabelFCB (drive, fcb);
    regs.ah := $13;
    regs.dx := Ofs (fcb);
    regs.ds := Seg (fcb);
    MSDos (regs);
    NukeVolumeLabel := regs.al;
end;

{ This routine massages a user-supplied volume label.  It is rejected if
  any invalid characters are supplied, alpha's are uppercased, and it's
  converted into 8.3 format preceeded by 'X:\'. }

function MassageVolumeLabel (VolLabel: String): String;
var
   i: Integer;
   str: String;
begin
   str := '';
   MassageVolumeLabel := '';
   { Validate the user input }
   if Length (VolLabel) > 11 then VolLabel [0] := Chr (11);
   for i := 1 to Length (VolLabel) do
   begin
       if StrScan ('*?/\|.,;:+=[]()&^<>"', VolLabel [i]) <> Nil then Exit;
       if Length (str) = 8 then str := str + '.';
       str := str + UpCase (VolLabel [i]);
   end;

   MassageVolumeLabel := 'X:\' + str;
end;

{ create a volume label - assumes there's not one already there }

function CreateVolLabel (drive: Byte; volName: String): Integer;
var
    i: Integer;
    regs: TRegisters;
    path: array [0..20] of Char;

begin
    CreateVolLabel := -1;
    StrPCopy (path, MassageVolumeLabel (volName));
    if path [0] = #0 then Exit;         { label was invalid }
    path [0] := Chr (drive + $40);      { 1=A, 2=B, etc... }

    FillChar (regs, sizeof (regs), 0);  { safe p-mode programming... }
    regs.ah := $3C;                     { specify create file        }
    regs.cx := 8;                       { set volume label attribute }
    regs.dx := Ofs (path);              { set up pointer to name     }
    regs.ds := Seg (path);              { DS:DS is the pointer pair  }
    MSDos (regs);                       { do the business...         }

    if not (Odd (regs.Flags)) then      { if no carry, then ok }
    begin
        _lclose (regs.ax);
        CreateVolLabel := 0;
    end;
end;

{ Higher-level volume settings code.  Takes care of replacing,
  nuking, etc. }

function SetDriveLabel (drive: Integer; VolLabel: String): Integer;
var
    err: Integer;
    OldLabel: String;
begin
    err := 0;
    OldLabel := GetDriveLabel (drive);

    { If old and new labels are the same, nothing to do }
    if OldLabel <> VolLabel then
    begin
        { If got an old label, then delete it }
        if OldLabel <> '' then err := NukeVolumeLabel (drive);
        { If we've got a new label, then set it up }
        if (err = 0) and (VolLabel <> '') then err := CreateVolLabel (drive, volLabel);
    end;

    SetDriveLabel := err;
end;

end.